perm filename INITIA[MAC,LSP] blob
sn#573510 filedate 1981-03-19 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00011 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 INITIA -*-LISP-*-
C00004 00003
C00016 00004
C00019 00005
C00025 00006
C00029 00007
C00034 00008
C00038 00009
C00044 00010
C00048 00011
C00051 ENDMK
C⊗;
;;; INITIA -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ***** (Initialization for COMPLR) *************
;;; **************************************************************
;;; ** (C) Copyright 1981 Massachusetts Institute of Technology **
;;; ****** This is a Read-Only file! (All writes reserved) *******
;;; **************************************************************
(SETQ INITIAVERNO '#.(let* ((file (caddr (truename infile)))
(x (readlist (exploden file))))
(setq |verno| (cond ((fixp x) file) ('/107)))))
(EVAL-WHEN (COMPILE)
(AND (OR (NOT (GET 'COMPDECLARE 'MACRO))
(NOT (GET 'OUTFS 'MACRO)))
(LOAD `(,(cond ((status feature ITS) '(DSK COMLAP))
('(LISP)))
CDMACS
FASL)))
)
(EVAL-WHEN (COMPILE) (COMPDECLARE) (FASLDECLARE) (GENPREFIX |/|in|) )
(EVAL-WHEN (EVAL) (SETQ CAR 'T))
(AND (NOT (STATUS FEATURE SAIL))
(MAPC '(LAMBDA (X)
(LET (((TYPE FUN . L) X) (PROP))
(SETQ PROP (GET FUN TYPE))
(MAPC '(LAMBDA (X) (AND (NOT (GET X TYPE))
(PUTPROP X PROP TYPE)))
L)))
'((FSUBR UREAD EREAD) (LSUBR OPEN EOPEN) (SUBR LOAD ELOAD))))
(COMMENT INITIALIZING FUNCTIONS)
(DEFUN INITIALIZE FEXPR (L)
(SSTATUS FEATURE COMPLR)
(SSTATUS FEATURE NCOMPLR)
(SETQ OPSYS (STATUS FILESYSTEM-TYPE)) ;I REALLY INTENDED THIS TO BE
(AND (EQ OPSYS 'DEC10) ; "FILESYSTEM-TYPE", BUT ...
(EQ (STATUS OPSYSTEM-TYPE) 'SAIL)
(SETQ OPSYS 'SAIL))
(SETQ MAKLAP-DEFAULTF-STYLE 'MIDAS)
(SETQ OBARRAY (SETQ SOBARRAY (GET 'OBARRAY 'ARRAY)))
(SETQ READTABLE (SETQ SREADTABLE (GET 'READTABLE 'ARRAY)))
(SETQ SWITCHTABLE ;Setup before INTERNing
(APPEND '(
(/$ FLOSW () ) (/+ FIXSW () ) (/} QUIT-ON-ERROR () )
(/2 HUNK2-TO-CONS ()) (/7 USE-STRT7 ())
(A ASSEMBLE () ) (C CLOSED () )
(D DISOWNED () ) (E EXPR-HASH () )
(F FASL #.(AND (MEMQ COMPILER-STATE '(MAKLAP DECLARE)) T))
(G GAG-ERRBREAKS () ) (H EXPAND-OUT-MACROS T)
(I INITIALIZE () )
(K NOLAP #.(AND (MEMQ COMPILER-STATE '(MAKLAP DECLARE)) T))
(M MACROS () ) (O ARRAYOPEN T) (S SPECIALS () )
(T TTYNOTES #.(AND (NOT (MEMQ COMPILER-STATE
'(MAKLAP DECLARE))) T))
(W MUZZLED () ) (X MAPEX () )
(Y YESWARNTTY #.(AND (NOT (MEMQ COMPILER-STATE
'(MAKLAP DECLARE))) T) )
(Z SYMBOLS () )
)
()))
(PUSH (COND (#%(SAILP)
(SETQ MAKLAP-DEFAULTF-STYLE () )
'(U UNFASLCOMMENTS () ))
( '(U UNFASLCOMMENTS T)))
SWITCHTABLE)
(DO I 65. (1+ I) (> I 90.)
(AND (NOT (ASSQ (ASCII I) SWITCHTABLE))
(PUSH (LIST (ASCII I)
(IMPLODE (APPEND '(S W I T C H /-) (LIST (ASCII I))))
() )
SWITCHTABLE)))
(COND ((STATUS FEATURE NO-EXTRA-OBARRAY)
(SETQ CREADTABLE READTABLE COBARRAY OBARRAY))
('T (SETQ CREADTABLE (ARRAY
()
READTABLE
(COND ((AND (BOUNDP 'IREADTABLE)
(EQ (TYPEP IREADTABLE) 'ARRAY)
(EQ (CAR (ARRAYDIMS IREADTABLE))
'READTABLE))
IREADTABLE)
('T))))
(SETQ COBARRAY (ARRAY
()
OBARRAY
(COND ((AND (BOUNDP 'IOBARRAY)
(EQ (TYPEP IOBARRAY) 'ARRAY)
(EQ (CAR (ARRAYDIMS IOBARRAY))
'OBARRAY))
IOBARRAY)
((GET 'OBARRAY 'ARRAY)))))
(LET ((OBARRAY COBARRAY) (READTABLE CREADTABLE))
(MAPC '(LAMBDA (X)
(COND ((NOT (EQ X (INTERN X)))
(REMOB X)
(INTERN X))))
(STATUS FEATURES))
(MAPC '(LAMBDA (X) (INTERN (CADR X))) SWITCHTABLE)
(MAPC 'INTERN SAIL-MORE-SYSFUNS)
; (AND #%(SAILP) (SETSYNTAX '/" 'MACRO '%%%STRING%%%) )
)))
(SETSYNTAX '/} 'MACRO 'MACR-AMP-FUN)
; (AND #%(SAILP) (SETSYNTAX '/" 'MACRO '%%%STRING%%%))
#%(LET ((PROP (LSUB '(MACRO SPECIAL ARGS *EXPR *FEXPR *LEXPR
NUMVAR NUMFUN *ARRAY OHOME SKIP-WARNING)
L))
(Z () )
(TMP () ) )
(MAPATOMS '(LAMBDA (Y)
(SETQ TMP (ASSQ Y CCLOAD:INITIAL-PROPS))
(LREMPROP Y (LSUB PROP (CDR TMP))) ;Remove compilation
(COND ((SETQ DATA (GET Y 'FUNTYP-INFO)) ;properties.
(COND ((ARGS Y))
((GET Y (CAR DATA)) (ARGS Y (CDR DATA)))
((CDR DATA) (PUTPROP Y (CDR DATA) 'ARGS))))
((AND (NOT (SYSP Y)) (NULL TMP)) (ARGS Y () )))
(AND (BOUNDP Y) ;SPECIALize the
(NOT (MEMQ Y '(T NIL))) ;system varialbes
(SETQ DATA Y)
(MEMQ 'VALUE (STATUS SYSTEM DATA))
(PUSH Y Z))))
(APPLY 'SPECIAL Z)
;; (STATUS SYSTEM) doesn't win on following
(AND (BOUNDP '+INTERNAL-INTERRUPT-BOUND-VARIABLES)
(APPLY 'SPECIAL +INTERNAL-INTERRUPT-BOUND-VARIABLES))
(SPECIAL +INTERNAL-WITHOUT-INTERRUPTS
VECTOR-CLASS CLASS-CLASS OBJECT-CLASS STRUCT-CLASS
STRUCT=INFO-CLASS SEQUENCE-CLASS)
(FASLINIT))
(PUTPROP '%HUNK1 '(() . 1) 'ARGS)
(PUTPROP '%HUNK2 '(() . 2) 'ARGS)
(PUTPROP '%HUNK3 '(() . 3) 'ARGS)
(PUTPROP '%HUNK4 '(() . 4) 'ARGS)
(SETQ PRINLEVEL (SETQ PRINLENGTH (SETQ *RSET () )))
(SETQ BASE 8. IBASE 8. *NOPOINT 'T)
(SETQ MACRO-EXPANSION-USE () )
(SETQ COMPILATION-FLAGCONVERSION-TABLE
'((EXPR . SUBR) (FEXPR . FSUBR) (LEXPR . LSUBR)))
(SETQ SPECVARS () GENPREFIX '(/| G) GFYC 0 P1GFY ()
CLOSED () FIXSW () FLOSW () MACROLIST ()
GAG-ERRBREAKS () RNL () CFVFL ()
UNDFUNS () P1LLCEK () LAPLL () ROSENCEK ()
FASLPUSH () RECOMPL () CMSGFILES () LAP-INSIGNIF 'T
EOC-EVAL () COMPILER-STATE 'TOPLEVEL CHOMPHOOK ()
USERATOMS-HOOKS '(EXTSTR-USERATOMS-HOOK) USERATOMS-INTERN ()
ALLUSERATOMS () TOPFN () ONMLS () READ () MSDEV 'DSK MSDIR ()
CL () CLEANUPSPL 0 FILESCLOSEP () IMOSAR ()
EOF-COMPILE-QUEUE () USER-STRING-MARK-IN-FASL T )
#%(SETUP-CATCH-PDL-COUNTS)
(MAPC '(LAMBDA (X) (SET (CADR X) (CADDR X))) SWITCHTABLE)
(MAPC '(LAMBDA (X) (SET X (COPYSYMBOL X () )))
'(PROGN GOFOO NULFU COMP CARCDR ARGLOC SQUID MAKUNBOUND IDENTITY
USERATOMS-INTERN-FROB))
(PUTPROP SQUID '(LAMBDA (GL) (LIST 'QUOTE GL)) 'MACRO)
(SETQ QSM (LIST (LIST 'QUOTE (LIST SQUID MAKUNBOUND))))
(SETQ STSL (LIST (DELQ 'TERPR (STATUS STATUS))
(DELQ 'TERPR (STATUS SSTATUS))))
(SETQ ARGLOC (LIST ARGLOC) CLPROGN (LIST PROGN))
(SETQ CAAGL (LIST (LIST (CONS MAKUNBOUND ARGLOC) 1)
(LIST (CONS MAKUNBOUND ARGLOC) 2)))
(SETQ MAPSB (NCONC (MAPCAR 'LIST '(VL EXIT EXITN PVR STSL))
(LIST (CONS 'GOFOO GOFOO))))
(SETQ COMAL (SUBST '() 'NIL '((NIL . NIL) (FIXNUM . FIXNUM) (FLONUM . FLONUM) (T))) )
(RPLACD (CAR COMAL) (CAR COMAL)) ;Sets up infinite
(RPLACD (CADR COMAL) (CADR COMAL)) ; type lists for COMARITH
(RPLACD (CADDR COMAL) (CADDR COMAL))
(FIXNUM BASE IBASE BPORG BPEND TTY) ;Some known declarations
(FIXNUM (LENGTH) (RANDOM) (EXAMINE FIXNUM) (LISTEN) (RUNTIME)
(GETCHARN NOTYPE FIXNUM) (FLATSIZE) (FLATC) (IFIX)
(↑ FIXNUM FIXNUM) (\\ FIXNUM FIXNUM) (LSH) (ROT) (ASH)
(SXHASH) (TYIPEEK) (TYI) (HAULONG) (HUNKSIZE)
(+INTERNAL-CHAR-N () FIXNUM)
(+INTERNAL-STRING-WORD-N () FIXNUM)
(LDB FIXNUM FIXNUM) (DPB FIXNUM FIXNUM)
(*LDB FIXNUM FIXNUM) (*DPB FIXNUM FIXNUM)
(LOAD-BYTE FIXNUM FIXNUM FIXNUM)
(DEPOSIT-BYTE FIXNUM FIXNUM FIXNUM FIXNUM)
(*LOAD-BYTE FIXNUM FIXNUM FIXNUM)
(*DEPOSIT-BYTE FIXNUM FIXNUM FIXNUM FIXNUM) )
(FIXNUM (IN) (LINEL) (PAGEL) (CHARPOS) (LINENUM) (PAGENUM) (LENGTHF))
(PUTPROP 'BOOLE (CONS (CADR COMAL) (CONS 'FIXNUM (CADR COMAL))) 'NUMFUN)
(PUTPROP IDENTITY 'T 'NUMBERP)
(PUTPROP 'FIXNUM-IDENTITY `(,IDENTITY FIXNUM) 'ARITHP)
(PUTPROP 'FLONUM-IDENTITY `(,IDENTITY FLONUM) 'ARITHP)
(FLONUM (SIN) (COS) (SQRT) (LOG) (EXP) (ATAN) (TIME)
(↑$ FLONUM FIXNUM) (FSC) (FLOAT))
(NOTYPE (GETCHAR NOTYPE FIXNUM) (CXR FIXNUM) (DEPOSIT FIXNUM))
(ARRAY* (NOTYPE OBARRAY 1 READTABLE 1))
(PUTPROP PROGN 'T '*LEXPR)
(COND (#%(SAILP)
(MAPC '(LAMBDA (X) (PUTPROP X 'T 'SKIP-WARNING))
'(PUSH POP LET))
(SSTATUS TTYINT 200. (STATUS TTYINT 194.))
(SSTATUS TTYINT 467. 'S-C)
(MAPC #'(LAMBDA (X)
(OR (GET X 'MACRO)
(PUTPROP X
(INTERN (PNAMECONC X '| | 'MACRO))
'MACRO)))
'(LET! MACRODEF TRANS TRANSDEF))))
(SSTATUS TTYINT '/≡ 'INT-↑↑-FUN)
(SSTATUS TTYINT '/¬ 'INT-↑↑-FUN)
(SSTATUS TTYINT '/ε 'DEBUG-BREAK)
(SETQ OBARRAY #.(COND ((MEMQ COMPILER-STATE '(MAKLAP DECLARE)) 'COBARRAY)
('SOBARRAY)))
(SETQ READTABLE #.(COND ((MEMQ COMPILER-STATE '(MAKLAP DECLARE)) 'CREADTABLE)
('SREADTABLE)))
(setq error-break-environment (cons cobarray creadtable))
(GCTWA))
(DEFUN DEBUG-BREAK N N
(NOINTERRUPT () )
(MSOUT-BRK ARGS SOBARRAY SREADTABLE 'SOBARRAY-ENVIRONMENT))
;;; Function for } macro char
(DEFUN MACR-AMP-FUN ()
((LAMBDA (OBARRAY READTABLE)
(COND ((= (TYIPEEK) #.(INVERSE-ASCII '/}))
(TYI)
(SETQ OBARRAY SOBARRAY READTABLE SREADTABLE)))
(READ))
COBARRAY CREADTABLE))
;;; Function for control-↑ interrupt
(DEFUN INT-↑↑-FUN N
(SETQ SAVED-ERRLIST ERRLIST ERRLIST () N (ARG 2))
(SSTATUS TOPLEVEL '(INT-↑↑-TOPLE))
(DO () ((OR (= (LISTEN) 0) (= (TYI) N))))
(↑G))
(DEFUN INT-↑↑-TOPLE () ;Starts up MAKLAP from ↑↑
#%(ERL-SET)
(SSTATUS TOPLEVEL () )
(COMPLRVERNO)
(NOINTERRUPT () )
(MAKLAP))
(DEFUN DB FEXPR (L) ;Setup for debugging
L
(SETQ SAVED-ERRLIST ERRLIST ERRLIST () )
(SSTATUS TOPLEVEL '(DB-TOPLE))
(↑G))
(DEFUN DB-TOPLE ()
(SSTATUS UUOLI)
#%(ERL-SET)
(*RSET (NOUUO 'T))
(SETQ OBARRAY SOBARRAY READTABLE SREADTABLE)
(SETQ ↑W (SETQ ↑R () ))
(SETQ ERRSET (FUNCTION (LAMBDA (X) X (BREAK ERRSET))))
(PROG (L)
A (COND ((NOT (GET 'BS 'FSUBR))
(COND (#%(ITSP) (SETQ L '((DSK LIBLSP) BS FASL)))
((PROBEF (SETQ L '((DSK) BS FASL))))
('T (TERPRI)
(PRINC '|Please load BS FASL!|)
(BREAK LOAD)
(GO A)))
(ELOAD L))))
(SSTATUS TOPLEVEL () ))
(DEFUN S-C (() ()) (CDUMP '|SAVE COMPLR|))
;This function never returns, but is a way to start up the toplevel complr
(DEFUN CDUMP N
(SETQ ERRLIST () SAVED-ERRLIST '((COMPLRVERNO)))
(SSTATUS TOPLEVEL '(COMPLR-TOPLE))
(SETQ CDUMP (LISTIFY N))
(OR (GET 'COMPLR 'VERSION)
(PUTPROP 'COMPLR COMPLRVERNO 'VERSION))
(*THROW () ())
;;(COMMENT Hopefully, this goes to a TOPLEVEL user of COMPLR-TOPLE)
)
(DEFUN COMPLR-TOPLE () ;Initial TOPLEVEL loop
(SETQ OBARRAY COBARRAY READTABLE CREADTABLE)
(SSTATUS TOPLEVEL () )
(SETQ - () + () )
#%(ERL-SET)
(SSTATUS NOFEATURE NOLDMSG)
(GCTWA 1)
(GC)
(APPLY (COND ((STATUS FEATURE SHARABLE)
(AND (NULL (CDR CDUMP)) (PUSH () CDUMP))
'PURE-SUSPEND)
('SUSPEND))
CDUMP)
(COMPLR-TOPLE-AFTER-SUSPEND))
(DEFUN COMPLR-TOPLE-AFTER-SUSPEND ()
;; This function is an entry-point which some systems
;; depend on. e.g. the macsyma-source-compiler. -gjc
(SSTATUS GCTIM 0)
#%(LET ((UID (STATUS USERID))
(USN (COND ((STATUS STATUS HOMED) (STATUS HOMED)) ((STATUS UDIR))))
(MSGFILES '(T))
(COMPILER-STATE 'DECLARE)
FIX-FILE FILE OFILE DEFAULTF-DEVICE)
(SETQ DEFAULTF-DEVICE (CASEQ OPSYS
(ITS '(DSK LSPDMP))
(DEC20 '(PS MACLISP))
(SAIL '(DSK (MAC LSP)))
(T '(LISP)))
DEFAULTF `(,defaultf-device * ,(caseq opsys
(ITS '>)
(SAIL '|←←←|)
(T 'LSP)))
FIX-FILE `(,defaultf-device CLFIX ,(get 'COMPLR 'VERSION)))
(SETQ DEFAULTF-DEVICE
`((,(car defaultf-device) ,(status UDIR)) ,.(cdr defaultf))
)
(COND ((STATUS FEATURE SHARABLE)
(ANNOUNCE-&-LOAD-INIT-FILE 'COMPLR () FIX-FILE))
('T (COMPLRVERNO)
(TERPRI)
(COND ((SETQ FIX-FILE (PROBEF FIX-FILE))
(TERPRI)
(PRINC '|Loading fix-up file |)
(PRIN1 (NAMESTRING FIX-FILE))
(COND ((ATOM (ERRSET (LOAD FIX-FILE)))
(PRINC '| *** Errors in Fix File ***|)
(BREAK FIX)))))
(SETQ OFILE `((,(cond (#%(dec20p) 'PS) ('DSK)) ,usn)
,.(cond (#%(itsp) `(,uid COMPLR))
('T `(COMPLR INI))))
FILE (PROBEF OFILE)
DEFAULTF DEFAULTF-DEVICE)
(COND ((COND (FILE)
(#%(ITSP)
(RPLACA (CDR OFILE) '*)
(AND (SETQ FILE (CAR (ERRSET (EOPEN OFILE '(NODEFAULT))
() )))
(SETQ FILE (TRUENAME FILE)))
FILE))
(TERPRI) (TERPRI)
(PRINC '|Loading COMPLR initialization file for |)
(PRINC (COND ((OR (EQ (CADR OFILE) '*) (NOT #%(ITSP))) USN)
(UID)))
(TERPRI)
(AND (ATOM (ERRSET (ELOAD FILE) 'T))
(PRINC '| *** Errors during loading *** BEWARE!| TYO)))) ))
(COND ((SETQ DATA (STATUS JCL))
(LET (WINP (JCL-LINE DATA))
(SETQ WINP (ERRSET
(PROG (M L LL)
(SETQ L DATA)
A (AND (< (SETQ M (GETCHARN (CAR L) 1)) 27.)
;Flush control chars
(NOT (= M 17.)) ;[except ↑Q] from
(SETQ L (CDR L)) ;front of JCL list
(GO A))
(SETQ LL ())
B (SETQ M (GETCHARN (CAR L) 1))
(PUSH (COND ((AND (< M 123.) (> M 96.))
(- M 32.)) ;Uppercaseify
(M)) ; rest of line
LL)
(AND (SETQ L (CDR L)) (GO B))
C (AND (< (CAR LL) 27.) ;Flush control
(SETQ LL (CDR LL)) ; chars from
(GO C)) ; end of line
(APPLY 'MAKLAP (NREVERSE LL)))
'T ))
(COND ((ATOM WINP)
(COND (WINP (PRINC '| *** Errors from JCL command *** /
;JCL = /"|)
(PRINC (MAKNAM JCL-LINE))
(PRINC '/"/
)
(BREAK JCL))
('T (PRINC '| *** Errors - randomness in COMPLR-TOPLE|)
(BREAK COMPLR-TOPLE))) ))
(INT-↑↑-TOPLE)))
('T (MAKLAP)))) )
;;; NOTE: THE LIST OF GLOBALSYMS SHOULD CORRESPOND TO
;;; THE LIST OF SYMBOLS AT LOCATION LSYMS IN LISP.
(DEFUN FASLINIT ()
(GETMIDASOP ())
(LET ((OBARRAY OBARRAY) (FL)
(PROPS '(SYM ATOMINDEX ARGSINFO ENTRY GLOBALSYM))
(ACS '(FOO A B C AR1 AR2A T TT D R F FOO P FLP FXP SP)))
(MAPATOMS '(LAMBDA (X) (LREMPROP X PROPS)))
(SETQ LDFNM (FASLAPSETUP/| () )) ;Sets up GLOBALSYMS
(COND ((AND (BOUNDP 'COBARRAY)
(EQ (TYPEP COBARRAY) 'ARRAY)
(SETQ FL (ARRAYDIMS COBARRAY))
(EQ (CAR FL) 'OBARRAY)
(NOT (AND (BOUNDP 'SOBARRAY) (EQ SOBARRAY COBARRAY))))
(SETQ FL '(% @ BLOCK ASCII SIXBIT SQUOZE CALL NCALL JCALL NJCALL
ENTRY DEFSYM BLOCK SYMBOLS BEGIN DDTSYM
THIS IS THE UNFASL FOR LISP FILE COMPILED BY COMPILER))
(MAPATOMS '(LAMBDA (X) (AND (GETL X '(SYM GLOBALSYM)) (PUSH X FL))))
;;;AFTER THE FASLAPSETUP/|, ONLY SYMS SHOULD BE GLOBALSYMS. IN ORDER:
;*SET *MAP PRINTA SPECBIND UNBIND IOGBND *LCALL *UDT ARGLOC
;INUM ST FXNV1 PDLNMK PDLNKJ FIX1A FIX1 FLOAT1 IFIX IFLOAT
;FXCONS FLCONS ERSETUP ERUNDO GOBRK CARCDR *STORE NPUSH PA3
;MAKUNBOUND FLTSKP FXNV2 FXNV3 FXNV4 FIX2 FLOAT2 AREGET
;UINITA UTIN INTREL INHIBIT NOQUIT CHECKI 0PUSH 0*0PUSH
;NILPROPS VBIND %CXR %RPX
(SETQ OBARRAY COBARRAY)
(MAPC 'INTERN FL) ;Cross-interns GLOBALSYMS
(MAPC 'INTERN (APPEND PROPS ACS))) ;Plus a few other words
(T (SETQ COBARRAY OBARRAY CREADTABLE READTABLE)))
(SETQ SQUIDP ()) ;Lists and set up GLOBALSYMS
(DO ((I 0 (1+ I)) (L ACS (CDR L))) ;Now define SYMS for LISP acs
((NULL L))
(AND (NOT (EQ (CAR L) 'FOO)) (PUTPROP (CAR L) I 'SYM)))
(ARRAY LCA T 16.) (ARRAY NUMBERTABLE T 127.)
(ARRAY BTAR FIXNUM 9.) (ARRAY BXAR FIXNUM 9.) (ARRAY BSAR T 9.)
(DO I 0 (1+ I) (= I 16.) (STORE (LCA I) (CONS I '((() -1)))))
(SETQ IMOSAR () IMOUSR ())
(SSTATUS FEATURE FASLAP)
(GCTWA)))
(COMMENT FILL INITIAL ARRAYS)
(ARRAY AC-ADDRS T #.(+ (NUMVALAC) (NUMNACS) 1))
(ARRAY PDL-ADDRS T 3 #.(+ 1 (NPDL-ADDRS)))
(ARRAY STGET T #.(+ (NUMVALAC) (NUMNACS)))
(ARRAY BOLA T #.(+ (NACS) (NUMNACS) 1) 7)
(ARRAY CBA T 16.)
(ARRAY A1S1A T #.(NUMNACS) 4)
(ARRAY PVIA T 3 (1+ (MAX #.(MAX-NPUSH) #.(MAX-0PUSH) #.(MAX-0*0PUSH))))
(PROGN (DO CNT #.(+ (NUMVALAC) (NUMNACS)) (1- CNT) (< CNT 1) ;Sets AC-ADDRS
(STORE (AC-ADDRS CNT) CNT))
(DO CNT #.(NPDL-ADDRS) (1- CNT) (< CNT 1) ;Sets PDL-ADDRS
(STORE (PDL-ADDRS 0 CNT) (- CNT #.(NPDL-ADDRS)))
(STORE (PDL-ADDRS 1 CNT) (- (+ CNT #.(FXP0)) #.(NPDL-ADDRS)))
(STORE (PDL-ADDRS 2 CNT) (- (+ CNT #.(FLP0)) #.(NPDL-ADDRS))))
;;; (STGET n) is for accessing segment table into register n
(DO CNT #.(+ (NUMVALAC) (NUMNACS) -1) (1- CNT) (< CNT 1)
(STORE (STGET CNT) (SUBST CNT 'N '(0 ST N))))
(DO ((HLAC #.(+ (NACS) (NUMNACS)) (1- HLAC))
(ATPL `((TDZA N N)
(MOVEI N ,(if (eq *:truth 'T) ''T '*:truth))
(SKIPE 0 N)
(MOVNI #.(NUMVALAC) N)
(MOVEI N '() )
(SKIPN 0 N))))
((< HLAC 1))
(DO ((CNT 1 (1+ CNT)) (ATPL1 ATPL (CDR ATPL1)))
((NULL ATPL1))
(STORE (BOLA HLAC CNT) (SUBST HLAC 'N (CAR ATPL1)))))
(FILLARRAY 'CBA '((SETZ) (AND) (ANDCA) (SETA) ;Sets CBA
(ANDCM) (SETM) (XOR) (IOR) (ANDCB)
(EQV) (SETCM) (ORCA) (SETCA)
(ORCM) (ORCB) (SETO)))
(DO CNT #.(- (NUMNACS) 1) (1- CNT) (< CNT 0) ;Sets A1S1A
(DO ((HLAC 0 (1+ HLAC)) (L '((ADDI 1)
(SUBI 1)
(FADRI 66304.) ;66304. = 201400[8]
(FSBRI 66304.))
(CDR L)))
((NULL L))
(STORE (A1S1A CNT HLAC) (LIST (CAAR L)
(+ CNT #.(NUMVALAC))
(CADAR L)))))
;;; Makes up array of JSPs to places that push the appropriate number
;;; of pdl-variable initialization values, onto the appropriate stack.
;;; (PVIA 0 n) ==> (JSP T (NPUSH -n)) pushes ()s onto REGPDL
;;; (PVIA 1 n) ==> (JSP T (0PUSH -n)) pushes 0s onto FXPDL
;;; (PVIA 2 n) ==> (JSP T (0*0PUSH -n)) pushes 0.0s onto FLPDL
(STORE (PVIA 0 0) #.(MAX-NPUSH))
(STORE (PVIA 1 0) #.(MAX-0PUSH))
(STORE (PVIA 2 0) #.(MAX-0*0PUSH))
(STORE (PVIA 0 1) '(PUSH P (% 0 0 '())))
(STORE (PVIA 1 1) '(PUSH FXP (% 0)))
(STORE (PVIA 2 1) '(PUSH FLP (% 0.0)))
(STORE (PVIA 0 2) 'NPUSH)
(STORE (PVIA 1 2) '0PUSH)
(STORE (PVIA 2 2) '0*0PUSH)
(DO CNT 0 (1+ CNT) (> CNT 2)
(DO HLAC (PVIA CNT 0) (1- HLAC) (< HLAC 3)
(STORE (PVIA CNT HLAC) (LIST 'JSP 'T (LIST (PVIA CNT 2) (- HLAC))))))
(COND (*PURE
(MAPC '(LAMBDA (GL)
(SETQ GL (GET GL 'ARRAY))
(DO CNT (1- (CADR (ARRAYDIMS GL))) (1- CNT) (< CNT 0)
(STORE (ARRAYCALL T GL CNT)
(PURCOPY (ARRAYCALL T GL CNT)))))
'(AC-ADDRS STGET CBA))
(MAPC '(LAMBDA (GL)
(SETQ GL (GET GL 'ARRAY))
(DO CNT (1- (CADR (ARRAYDIMS GL))) (1- CNT) (< CNT 0)
(DO HLAC (1- (CADDR (ARRAYDIMS GL)))
(1- HLAC)
(< HLAC 0)
(STORE (ARRAYCALL T GL CNT HLAC)
(PURCOPY (ARRAYCALL T GL CNT HLAC))))))
'(PDL-ADDRS BOLA A1S1A PVIA))))
)
(COMMENT PUT PROPERTIES ON VARIOUS SYMBOLS)
(PROGN (DEFPROP RPLACD (HRRM . HRRM) INST)
(DEFPROP RPLACA (HRLM . HRLM) INST)
(DEFPROP RPLACD (HLLZS . HLLZS) INSTN)
(DEFPROP RPLACA (HRRZS . HRRZS) INSTN)
(DEFPROP SETPLIST (HRRM . HRRM) INST)
(DEFPROP SETPLIST (HLLZS . HLLZS) INSTN)
(DEFPROP A (HLRZ . HLRZ) INST)
(DEFPROP D (HRRZ . HRRZ) INST)
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'IMMED))
'(MOVE CAMN CAME
ADD SUB IMUL IDIV CAMLE CAMG CAML CAMGE MOVN
AND ORCB SETCM XOR EQV IOR ANDCB ANDCA ANDCM ORCM ORCA)
'(MOVEI CAIN CAIE
ADDI SUBI IMULI IDIVI CAILE CAIG CAIL CAIGE MOVNI
ANDI ORCBI SETCMI XORI EQVI IORI ANDCBI ANDCAI ANDCMI ORCMI ORCAI))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'JSP))
'(CONS XCONS NCONS %HUNK1 %HUNK2 %HUNK3 %HUNK4)
'(
(((JSP T %CONS) .
(JSP T %C2NS))
. ((JSP T %PDLC) .
(JSP T %C2NS)))
(((JSP T %XCONS) .
(JSP T %PDLXC))
. PUNT )
(((JSP T %NCONS)) .
((JSP T %PDLNC)))
((JSP T %HUNK1))
((JSP T %HUNK2))
((JSP T %HUNK3))
((JSP T %HUNK4))
))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'COMMU) (PUTPROP INSTN INST 'COMMU))
'(CONS *GREAT *PLUS *TIMES EQUAL CAMG CAMGE JUMPGE JUMPL)
'(XCONS *LESS *PLUS *TIMES EQUAL CAML CAMLE JUMPLE JUMPG))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'CONV) (PUTPROP INSTN INST 'CONV))
'(JUMP JUMPL JUMPE JUMPLE TRNN TLNN SOJE CAMG CAML
CAMN CAIG CAIL CAIE SKIPE SKIPG SKIPL)
'(JUMPA JUMPGE JUMPN JUMPG TRNE TLNE SOJN CAMLE CAMGE
CAME CAILE CAIGE CAIN SKIPN SKIPLE SKIPGE))
;A status option with no STATUS property means no evaluation of its
; entries. "(x . y)" means "x" is for sstatus and "y" for status;
; x and y are "A" to mean evaluate all but option name, and "B" to
; mean evaluate all but option name and next thing.
(MAPC '(LAMBDA (Z Y) (MAPC '(LAMBDA (X) (PUTPROP X Z 'STATUS)) Y))
'((A . A) (() . A) (A . () ) (B . B))
'((TTY TTYRE TTYTY TTYCO TTYSC TTYIN LINMO PDLMA INTER
GCMIN GCSIZ GCMAX)
(DIVOV FTVSI + TOPLE UUOLI ABBRE GCTIM GCWHO WHO1 WHO2 WHO3
EVALH BREAK MAR CLI FLUSH PUNT RANDO /← LOSEF)
(SYSTE SPCSI PURSI PDLSI PDLRO FILEM TTYSI OSPEE HSNAM)
(MACRO SYNTA CHTRA)))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'MINUS))
'(MOVEI ADDI SUBI)
'(MOVNI SUBI ADDI))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'BOTH))
'(ADD SUB IMUL IDIV FADR FSBR FDVR FMPR)
'(ADDB SUBB IMULB IDIVB FADRB FSBRB FDVRB FMPRB))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'FLOATI))
'(FADR FSBR FMPR FDVR MOVE)
'(FADRI FSBRI FMPRI FDVRI MOVSI))
((LAMBDA (Y)
(MAPC '(LAMBDA (X)
(COND ((GET (CAR X) 'AUTOLOAD)
(COND ((NULL (CDDR X)))
((EQUAL (SETQ Y (ARGS (CAR X))) (CDDR X)))
(T (AND Y (ERROR '|ARGS data doesn't match|
X
'FAIL-ACT))
(ARGS (CAR X) (CDDR X))))
(AND (CDR X) (PUTPROP (CAR X) (CDR X) 'FUNTYP-INFO)))))
'((ALLFILES SUBR () . 1)
(CGOL FSUBR) (CGOLREAD LSUBR) (CREATE-JOB LSUBR 3 . 5)
(FORMAT LSUBR 2 . 510.) (INF-EDIT MACRO) (LEDIT FSUBR)
(LAP FSUBR) (LAP-A-LIST SUBR () . 1)
(DUMPARRAYS SUBR () . 2) (LOADARRAYS SUBR () . 1)
(DIRECTORY LSUBR 1 . 2) (MAPALLFILES SUBR () . 2)
(MAPDIRECTORY LSUBR 2 . 3)
(SORT SUBR () . 2) (SORTCAR SUBR () . 2)
(GRIND FSUBR) (GRIND0 FSUBR) (GRINDEF FSUBR)
(SPRINTER SUBR () . 1) (TRACE FSUBR)
(LOOP MACRO) (DEFINE-LOOP-PATH MACRO)
(DEFINE-LOOP-SEQUENCE-PATH MACRO)
(DEFVST MACRO) (SETVST MACRO) (STRUCT-TYPEP SUBR () . 1)
(STRINGP SUBR () . 1)
(*:FIXNUM-TO-CHARACTER SUBR () . 1)
(*:CHARACTER-TO-FIXNUM SUBR () . 1)
(MAKE-STRING LSUBR 1 . 2) (STRING-PNPUT SUBR () . 2)
(REPLACE LSUBR 2 . 5) (SUBSEQ LSUBR 1 . 3)
(TO-LIST LSUBR 1 . 3) (TO-VECTOR LSUBR 1 . 3)
(TO-STRING LSUBR 1 . 3) (TO-BITS LSUBR 1 . 3)
(SETSYNTAX-SHARP-MACRO LSUBR 3 . 4)
(PTR-TYPEP SUBR () . 1) (EXTENDP SUBR () . 1)
(SI:MAKE-EXTEND SUBR () . 2) (SI:EXTEND LSUBR 1 . 510.)
(SI:XREF SUBR () . 2) (SI:XSET SUBR () . 3)
(SI:DEFCLASS*-1 LSUBR 3 . 4)
(ADD-METHOD SUBR () . 3) (FIND-METHOD SUBR () . 2)
(WHICH-OPERATIONS SUBR () . 1) (DESCRIBE LSUBR 1 . 2)
(SEND-AS LSUBR 3 . 510.) (LEXPR-SEND LSUBR 2 . 510.)
(LEXPR-SEND-AS LSUBR 3 . 510.)
(Y-OR-N-P LSUBR) (YES-OR-NO-P LSUBR)
(CERROR LSUBR 4 . 510.) (FERROR LSUBR 2 . 510.))))
() )
(DEFPROP %CATCHALL (FSUBR) FUNTYP-INFO)
(DEFPROP %PASS-THRU (FSUBR) FUNTYP-INFO)
(MAPC '(LAMBDA (X) (PUTPROP X 'NOTNUMP 'NOTNUMP)) ;Has no side-effects
'(
%HUNK1 %HUNK2 %HUNK3 %HUNK4 *APPEND ALPHALESSP
APPEND ARRAYDIMS ASSOC ASSQ ATOM BAKLIST
BIGP BOUNDP CONS COPYSYMBOL ERRFRAME
EVALFRAME EXPLODE EXPLODEC EXPLODEN
FILEP FIXP FLOATP GETCHAR GETL HUNK
HUNKP LAST LISTARRAY LISTIFY MAKNAM
MEMBER MEMQ NCONS NTHCDR NULL NUMBERP
PLIST PNGET REVERSE SAMEPNAMEP SIGNP
SUBLIS SUBST SYMBOLP SYSP TYPEP XCONS
))
(MAPC '(LAMBDA (X) (PUTPROP X 'EFFS 'NOTNUMP)) ;Has side-effects
'(
*ARRAY *DELETE *DELQ *NCONC *READCH *REARRAY
ALARMCLOCK ASCII CURSORPOS DELETE DELQ DUMPARRAYS
FILLARRAY GENSYM IMPLODE INTERN LOADARRAYS NCONC NRECONC
NREVERSE READCH REMOB REMPROP SASSOC SASSOC SASSQ SETPLIST
SETSYNTAX SORT SORTCAR SUSPEND TERPRI VALRET
))
(MAPC '(LAMBDA (X) (PUTPROP X 'T 'NOTNUMP)) ;Has side-effects, and returns T
'(TYO /+TYO *TYO DEPOSIT PRIN1 PRINC PRINT *PRIN1 *PRINC *PRINT))
;;; In general, function-names with ACS properties have no side-effects, except
;;; for those explicity mentioned under the NOTNUMP property above. Thus
;;; (NOT (GET x 'ACS)) is a general test for potentially-random side-effects.
(MAPC '(LAMBDA (DATA)
(MAPC '(LAMBDA (X) (AND (SYSP X) (PUTPROP X (CADAR DATA) (CAAR DATA))))
(CDR DATA)))
'(
((ACS 1) IN OUT CLOSE LINEL PAGEL CHARPOS LINENUM PAGENUM
CLEAR-INPUT CLEAR-OUTPUT FORCE-OUTPUT NAMELIST
TRUENAME PROBEF DELETEF DEFAULTF FASLP)
((ACS 2) MERGEF)
((ACS 3) NAMESTRING SHORTNAMESTRING)
((ACS 4) RUBOUT RENAMEF ENDPAGEFN EOFFN FILEP DELETEF FILEPOS
LENGTHF CNAMEF)
((ACS 5) OPEN)
;Missing are INCLUDE and LOAD, because they may cause
; totally unforseen side-effects
((ACS 1) LENGTH ADD1 SUB1 MINUS ABS FLOAT FIX
SIN COS SQRT LOG EXP ZEROP PLUSP MINUSP ODDP
1+ 1- 1+/$ 1-/$)
((ACS 1) LAST SLEEP RANDOM NOINTERRUPT EXAMINE
ARG MUNKAM ERRFRAME)
((ACS 2) PLUS TIMES EXPT DIFFERENCE QUOTIENT MAX MIN
GREATERP LESSP ATAN
*PLUS *TIMES *GREAT *QUO *DIF *LESS /\/\ /↑ /↑$
HAULONG HAIPART GCD BOOLE REMAINDER)
((ACS 2) GET REMPROP MEMQ RECLAIM EQUAL DEPOSIT
CONS NCONS XCONS SUBLIS NCONC *NCONC *DELQ
DELQ ASSQ ALARMCLOCK SETARG SETPLIST MAKNUM
SAMEPNAMEP ALPHALESSP GETCHARN LISTIFY
NTH NTHCDR)
((ACS 3) GENSYM FLATSIZE FLATC PNGET EVALFRAME PURIFY
LISTARRAY FILLARRAY DUMPARRAYS ARRAYDIMS
PRINT PRIN1 PRINC *PRINT *PRIN1 *PRINC
SYSP COPYSYMBOL SXHASH MAKNAM GETL
REVERSE NREVERSE NRECONC GETL PUTPROP ARGS)
((ACS 4) ASSOC SASSOC SASSQ CRUNIT)
((ACS 4) %HUNK1 %HUNK2 %HUNK3 %HUNK4)
((ACS 5) SUBST *DELETE DELETE MEMBER *APPEND APPEND
*ARRAY *REARRAY LOADARRAYS
BAKTRACE BAKLIST ERRPRINT
ALLOC *FUNCTION SUSPEND SETSYNTAX
EXPLODEC EXPLODE EXPLODEN
PNPUT INTERN IMPLODE REMOB ASCII READCH *READCH
*TERPRI TERPRI *TYO TYO /+TYO *TYI TYI TYIPEEK
CURSORPOS
GETMIDASOP GETDDTSYM PUTDDTSYM
UREAD UWRITE UKILL UFILE UPROBE UCLOSE UAPPEND
)))
;EVAL, *EVAL, READ, *READ and MAP series aren't here, since
; they permint random evaluations [hence random side effects]
;PAGEBPORG isn't here since it setqs BPORG, and may cause a GC.
(MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'P1BOOL1ABLE))
'(AND OR NULL NOT EQ = > < COND MEMQ SIGNP))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'NUMBERP 'P1BOOL1ABLE))
'(EQUAL GREATERP LESSP ODDP *GREAT *LESS ZEROP PLUSP MINUSP))
(MAPC '(LAMBDA (INST INSTN)
(PUTPROP INST
(CONS (CONS 'TLNN INSTN) (CONS 'TLNE INSTN))
'P1BOOL1ABLE))
'(ATOM NUMBERP FIXP FLOATP BIGP HUNKP SYMBOLP)
;(175300 161000 120000 40000 20000 20 10000)
'(64192. 57856. 40960. 16384. 8192. 16. 4096.))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'CONTAGIOUS))
'(PLUS TIMES DIFFERENCE QUOTIENT *PLUS *TIMES *DIF *QUO))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'NUMBERP))
'(PLUS TIMES DIFFERENCE QUOTIENT *PLUS *TIMES *DIF *QUO
ABS MINUS FIX FLOAT IFIX ADD1 SUB1 REMAINDER HAULONG))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'NOTYPE 'NUMBERP))
'(GREATERP LESSP *GREAT *LESS EQ EQUAL ODDP ZEROP PLUSP MINUSP))
(MAPC '(LAMBDA (X) (PUTPROP (CAR X) (CDR X) 'ARITHP))
'( (/+ PLUS FIXNUM) (+$ PLUS FLONUM)
(/- DIFFERENCE FIXNUM) (-$ DIFFERENCE FLONUM)
(/* TIMES FIXNUM) (*$ TIMES FLONUM)
(/1+ ADD1 FIXNUM) (1+$ ADD1 FLONUM)
(/1- SUB1 FIXNUM) (1-$ SUB1 FLONUM)
(// QUOTIENT FIXNUM) (//$ QUOTIENT FLONUM)
(/> GREATERP () ) (/< LESSP () )
(/\ REMAINDER FIXNUM) (/= EQUAL () )
;; (FIXNUM-IDENTITY IDENTITY FIXNUM) ;SET UP BY INITIALIZE
;; (FLONUM-IDENTITY IDENTITY FLONUM) ;SET UP BY INITIALIZE
))
)
β